perm filename P.F4[PAG,LCS] blob
sn#469472 filedate 1979-08-28 generic text, type T, neo UTF8
C***** AIDS IN EXTRACTING PARTS FROM SCORES AND DOES AUTOMATIC PAGE LAYOUT.
C***************************** THERE ARE STILL SEVERAL BUGS IN THIS PROG.
C***************************** TRANSPOSE-ONLY IS NOT FULLY TESTED.
C*********** TRANSPOSITION OF 'F' PARTS IN BASS CLEF HAS SOME PROBLEMS.
C***************************** ETC., ETC. 8/78
C SEE PAGE.CMD FOR LOADING INSTRUCTIONS
C **** SUBROUTINE LIST *****
C PAGE: READX
C RESPC:
C RESTP:
C WRTPAG:
C PGSUB: FILOUT(NAMQ,NPG), FILEIN, STAVES
C TRONLY:
C TRNSP: TRNSP, RVRS
C PTMOVX: PTMOVE, TURN
C FNDTRN: MNMX, FNDTRN, BRJUGL, GET
C PFAIL: LOOKF,LOOKX,LOOK,SHFTQ,SORT2,NORH,FNDEND,MINMAX,RLOOP,BLTEM,IFIX,FLOAT
C GETPTS,MOVIT,EXTEN,DBAR,QRN,SORT,SHIFT,SHFT1,SHFT0,PSHFT,ADRST,STAFF
C RIGHT,RESTS,EXCHG,EXCH,SHRNK,EXPND,CLFNUM,SLRV,CLEFN,MMNN,CODEN,ZERO
C EXT: PUTEXT,EXTOUT,GETEXT,EXTIN,FINEXT
COMMON/STF/RSTFAC(0/7),RSTJ2 /POSI/STFF(0/7),JJ2,JPQ
1 /IPG/IPG,JPG,BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),
1 RCLEF(0/7) /RSIG/RSIG(0/7) /IVV/NRD(200)
COMMON RS,JA,REST,J2,RQ(18),JX,PR,LX,RDIS
C ORDER OF COMMON BLOCKS **MUST** STAY AS IS!
COMMON/XRN/RN(3000) /SF/KL,RT,KP,STFSZ,NAMX,EXT
1 /PTR/KWDS(300)/LLL/LLL,LL,I,IX,XSIG/XXX/LK,LP,JY /JN/J,N
C INCREASE DIMENSION OF KWDS (KPN & Q) FOR VERY FULL PAGES.
DIMENSION MM(1500),NN(1500),BARS(509),STFNM(0/7),KSAVE(30),
1 RMETER(0/7),RCL(0/7),NUMS(30),PGTRN(500),SAVES(470)
C KSAVE AND SAVES ARE TO SAVE REHEARSAL NUMS, ETC. -- LIMIT=30
COMMON /PX/KPN(350) /Q/Q(3500) /KBAR/KBAR(1027) /IRST/IRST
1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,RNAM3
1 /RSP/KNM(100) /ENDL/ENDLN,KQ,NAME,NMPG,SPCNT,LASTNM
DATA FIB/.7/,RSPC/25./,PGNUM/1.6/,RNMHT/16.0/,RNMSZ/1.0/
1 ,RLTRSZ/1.0/,SPCPG/2.7/
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5))
1,(MM,RN),(NN,RN(1501)),(KS,RS),(BARS,KBAR(4)),(JRSTF,RSTJ2)
1,(R8,RQ(6)),(R9,RQ(7)),(RQ(10),XLFT),(KBR,KBAR),(T,KBAR(2))
1,(STFNM,KBAR(508)),(NUM1,NUMS,KPN),(PGTRN(1),KBAR(5 16))
1,(SAVES,Q(3001)),(KSAVE,Q(3475))
C HANDLES 503 PAGES AND PAGE-TURN INFO. IN KBAR AND PGTRN
C RQ(2) IS R4, RQ(3) IS R5 ETC. STAFF NAMES START AT KBAR(508)=STF(0)
RN(2)=0
EXT='DMD'
IRST=0
C IRST IS USED IN SUBROUTINE RESTP
IPG=0
KBR=0
NMPG='PAGEA'
JPG=0
JRD=1
ENDLN=0
SAVSIZ=0
ISN=0
NCNT=10000
TYPE 1000
ACCEPT 2000,NAMX
IF(NAMX.EQ.0)CALL PT2
IF(NAMX.EQ.3)CALL TRONLY
NPG=NAMX-2
TYPE 3300
IF(NPG.GE.0)GO TO 3000
CC IF(NPG.GE.0)TYPE 3
ACCEPT 2,KS,NTYPE
C TYPE -1 AFTER NAME(I.E.5 SPACES) TO PRINT INST. NAMES AS READ.
CC NAMZ=KS
JNM=1
CALL LO2UP(KS)
143 CALL IFILE(1,KS)
READ(1,2)K
CC843 READ(1,2)K
IF(K.NE.'COMME')GO TO 543
743 READ(1,643),K,K,K
C READ ET DIRECTORY !∃∀ βλπα∀πεβα!ββX!
IF(K.NE.';')GO TO 743
READ(1,2)K
GO TO 843
C FIRST LINE MUST BE EXTENSION NAME
643 FORMAT(3A1)
2 FORMAT(A5,30I)
CC3 FORMAT(' TYPE FILE NAME.EXT -- '$)
3300 FORMAT(' TYPE FILE NAME -- '$)
1000 FORMAT(' 1=PARTS, 2=PAGE LAYOUT, 3=TRNSP ONLY, 0=OLD '$)
2000 FORMAT(I)
CC543 READ(1,2,END=343),KNM(JNM),(KPN(K),K=1,30)
543 CALL IFILE(1,KS)
843 CALL READX(1,KNM(JNM),EXT,KEND,NUMS)
IF(KEND)GO TO 343
JNM=JNM+1
DO 434 K=1,30
J=KPN(K)
JPG=JPG+1
NRD(JPG)=J
C BE CAREFUL ABOUT RUNNING OVER NRD ARRAY (100)-- ZEROS ARE INSERTED***********
434 IF(J.EQ.0)GO TO 843
GO TO 843
CC3000 CALL NAMEXT
3000 CALL READX(5,NAMX,EXT,KEND,NUMS)
KNM(1)=NAMX
GO TO 4000
343 KNM(JNM)=-1
NXX=NRD(1)
C NXX COULD BE EQUIV. TO NRD(1)!!
4000 NAMZ=KNM(1)
IF(NPG.GE.0.AND.NUM1.GT.0)NCNT=NUM1
C TYPE A # AFTER FILE NAME TO SET # OF FILES TO BE READ.
DO 911 K=0,7
RCLEF(K)=99
RCL(K)=99
RMETER(K)=99
C INITS STUFF FOR PAGE LAYOUT
BRACK(K)=0
911 RSIG(K)=99
744 XSIG=FIB
CLEF=-1
XMTR=FIB
XLFT=0
JPG=0
YCLEF=2.
YSIG=2.
YMTR=2.
RSTAFF=0
RM=0
JNM=1
CZ1344 JNM=1
1344 IF(NCNT.EQ.0)GO TO 1212
C NCNT IS INPUT FILE COUNTER.
NCNT=NCNT-1
ZLFT=.5
KQ=0
IF(NPG.EQ.0)JRD=0
LLL=1
LK=1
86 FORMAT(1XA5)
186 FORMAT(1XA5,'.',A3)
83 NAME=KNM(JNM)
CZ JNM=JNM+1
IF(NAME.EQ.-1)GO TO 1212
CC JRD=JRD+1
CXCX NXX=NRD(JRD+1)
CZ NXX=NRD(JRD)
C????????????? IF(KBR.EQ.0)GO TO 284
JZ=-1
10 IF(LOOKX(NAME,EXT))GO TO 284
CZ100 IF(JZ)GO TO 344
C FOUND NO MORE TO READ
344 NAME=NAMZ+256
C UPDATE 4TH CHAR. (E.G. AAAAA TO AAABA)
NAMZ=NAME
CZ JZ=0
KNM(JNM)=NAME
IF(LOOKX(NAME,EXT))GO TO 284
CZ IF(LOOKX(NAME,EXT).GE.0)GO TO 284
C NOW ALL DONE WITH INPUT, START OUTPUT
1212 CALL PUTEXT('BARS','PAG')
CALL EXTOUT(KBAR,1024)
RSTJ2=SAVSIZ
CALL EXTOUT(RSTFAC,128)
CALL FINEXT
C K (NUM OF BARS - UP TO 511) IS FIRST LOC OF KBAR.
CALL PT2(KPN,Q,KWDS,RN)
284 JZ=0
SN=0
IF(NPG)SN=200
SNMTR=SN
IF(RM.NE.0)GO TO 277
RM=-1
4 FORMAT(' TYPE INST NAME '$)
IF(NPG.GE.0)GO TO 277
TYPE 4
ACCEPT 2,RNAM,K
CALL LO2UP(RNAM)
RNAM2=-1
RNAM3=-1
RNAM4=-1
IF(K.EQ.0)GO TO 277
TYPE 177
ACCEPT 2,RNAM2,K
CALL LO2UP(RNAM2)
IF(K.EQ.0)GO TO 277
C TYPE NUM AFTER NAME TO ENTER UP TO 4 NAMES.
TYPE 177
ACCEPT 2,RNAM3
CALL LO2UP(RNAM3)
TYPE 177
ACCEPT 2,RNAM4
CALL LO2UP(RNAM4)
177 FORMAT(' OTHER INST NAME ',$)
277 TYPE 186,NAME,EXT
CALL GETEXT(NAME,EXT)
C LP IS START OF RN ARRAY THIS TIME
CALL EXTIN(RSTFAC,20)
CALL EXTIN(KWDS,JJ2)
CALL EXTIN(RN,JPQ)
IF(JRSTF.LT.10000)RSTJ2=1.0
C X!Z+*↑: WHERE IS THE BUG THAT PUTS AN INTEGER INTO RSTJ2????
CZ IF(SAVSIZ.EQ.0)SAVSIZ=RSTJ2
IPG=NPG
C IPG MUST BE RESET EACH TIME BECAUSE READIN WIPES IT OUT.
CALL RLOOP(Q,RN,JPQ)
ITEM=JJ2-2
1211 R=RN(KWDS(1)+2)
K=2
LS=1
J=0
C SORTS NOTES AND RHYTH ONLY
1111 KX=KWDS(K)
RA=RN(KX+2)
IF(RA.GE.R)GO TO 1011
CALL EXCH(KWDS(K),KWDS(LS))
J=-1
1011 R=RA
2611 LS=K
K=K+1
IF(K.LE.ITEM)GO TO 1111
IF(J)GO TO 1211
C NOW ALL SORTED (BY STAFF)
J=1
KW=1
DO 1311 K=1,ITEM
LS=KWDS(K)
IF(RN(LS+1).GT.2)GO TO 2711
RN(LS+3)=RN(LS+3)-.001
C MOVE ALL NOTES AND RESTS SLIGHTLY TO LEFT. (FOR SORTER)
2711 M=RN(LS)+3
CALL RLOOP(Q(J),RN(LS),M)
J=J+M
KPN(K)=KW
1311 KW=KW+M
KPN(ITEM+1)=KW
CC DO 1511 K=1,ITEM+1
CC1511 KWDS(K)=KPN(K)
CC DO 1611 K=1,JPQ
CC1611 RN(K)=Q(K)
CALL BLTEM
C BLTEM BLTS ARRAYS KPN AND Q INTO KWDS AND RN
DO 18 K=1,JPQ
18 Q(K)=0
C ZERO IT FOR FUTURE SAFETY
JCUE=0
RLFT=10000
811 DO 577 K=1,ITEM
R=CODEN(KWDS,K,RN,J)
IF(R.GT.2)GO TO 809
IF(RLFT.GT.RN(J+3))RLFT=RN(J+3)
C RLFT IS LEFT-MOST NOTE OR REST. USED FOR DISCARDING ENTERING SLURS.
GO TO 577
809 IF(R.LT.4)GO TO 577
RWD=RN(J)
C RWD IS WDCNT OF EACH ITEM
JS=RN(J+2)
IF(IPG.LT.0)GO TO 111
C IPG=-1 = EXTRACTING PARTS, =0 = PAGE LAYOUT.
IF(R.NE.8)GO TO 211
STFNM(JS)=0
IF(RWD.GE.7)STFNM(JS)=RN(J+9)
CC **** 10/77 IF(RWD.LE.7)STFNM(JS)=RN(J+9)
C SAVES STAFF IDENT. NAME
1811 IF(ENDLN.NE.0)GO TO 577
JPG=JPG+1
LS=JS+1
RSTNUM(LS)=JS
RHGT(LS)=0
IF(RWD.GE.2)RHGT(LS)=RN(J+4)
RPSZ(LS)=RSTFAC(JS)
IF(SAVSIZ.EQ.0)SAVSIZ=RPSZ(LS)
CC RPSZ(LS)=RSTFAC(IFIX(R5))
C***211 RN(J+2)=RN(J+2)*.1
C*** STAFF NUMS WILL NOW BE -.3 UP TO +.4. NO STAFF NAME NEEDED.
IF(R5.EQ.0)SPCNT=SPCPG*RPSZ(LS)
211 IF(R.NE.4)GO TO 577
IF(RN(J+3).LT.ZLFT)GO TO 311
C ASSUMES STAFF, LFT POS., HAS ALREADY BEEN SEEN. (ZLFT=P3+.5)
IF(RN(J+2).EQ.0)GO TO 577
511 RN(J+1)=44
C BARS NOT ON STAFF ZERO NOW HAVE CODE NUM. 44
GO TO 577
311 IF(IPG.LT.0)GO TO 577
IF(ENDLN.NE.0)GO TO 577
CC IF(RWD.GE.5)BRACK(LS)=RN(J+7)+RN(J+4)*100.
IF(RWD.GE.5)BRACK(JS)=RN(J+7)+RN(J+4)*100.
C SAVE 'BRACKET' INFO (P7=3,4 OR 5) - CAN FIND WRONG THING!!
CCC IF(RWD.GE.5)GO TO 511
GO TO 577
111 IF(R.NE.8)GO TO 112
IF(RWD.LT.7)GO TO 577
C NO NAME ON THIS STAFF - SO JUMP
IF(RN(J+7).NE.0)GO TO 577
C SKIPS INVISIBLE STAVES.
XLFT=RN(J+3)
C LEFT LIMIT OF STAFF
R9=RN(J+9)
IF(NTYPE.LT.0)TYPE 86,R9
IF(R9.EQ.RNAM)GO TO 977
IF(RNAM2.EQ.R9)GO TO 977
IF(RNAM3.EQ.R9)GO TO 977
IF(RNAM4.NE.R9)GO TO 577
977 I=JS+RSTAFF
SN=I
SNMTR=SN
RPSZ(1)=RSTFAC(JS)
IF(SAVSIZ.EQ.0)SAVSIZ=RPSZ(1)
IF(NXX.GT.1)NXX=-NXX
C SO IT WON'T LOOK ON MORE STAVES IN OTHER FILES.
JCUE=-1
IF(IPG.LT.0)TYPE 1577,R9,NAME
GO TO 577
1577 FORMAT(1XA5,' FOUND IN ',A5)
CXXX GO TO 477
112 IF(IPG.GE.0)GO TO 577
IF(R.NE.10)GO TO 577
C SKIPS PAGE NUMS. (I.E. P7 > 2)
IF(RN(J+6).LT.100)GO TO 577
C SAVE NUMBER IF SIZE FACTOR(R6) IS +100 (JUST LIKE CODE 16)
C******ALL THIS TO 800-1 CAN NOW BE TAKEN OUT. USE P6+100 FOR REHRSL. #S.
RN(J+4)=RNMHT
RN(J+6)=RNMSZ
C THE ABOVE SET HEIGHT AND SIZE OF REHEARSAL NUMS.
RN(J+2)=0
C PARTS ARE ALWAYS ON STAFF 0
CX JS=J
JJK=RWD+2+LK
CX DO 1112 JJJ=LK,JJK
CX SAVES(JJJ)=RN(JS)
CX1112 JS=JS+1
I=JJK-LK+1
CALL RLOOP(SAVES(LK),RN(J),I)
C PUTS RN INTO SAVES
LK=JJK+1
RN(J+2)=10.
LLL=LLL+1
KSAVE(LLL)=LK
577 CONTINUE
C DIDN'T FIND USEFUL INFO SO SKIP THIS FILE
CX IF(JCUE)GO TO 477
CCC IF(IPG)TYPE 1577,RNAM,NAME
477 I=JPQ-2
C READS AND WRITES 1 EXTRA WORD
IF(IPG.EQ.0)GO TO 13
IF(NXX.GT.0)GO TO 877
C NEXT FOR PARTS ONLY. TO SKIP A FILE (OR MORE)
NAME=NAME-2*(NXX+1)
NXX=1
877 NXX=NXX-1
KNM(JNM)=NAME
NAME=NAME+2
IF(NXX.NE.0)GO TO 277
JRD=JRD+1
NXX=NRD(JRD)
IF(NXX.NE.0)GO TO 44
JNM=JNM+1
NAMZ=KNM(JNM)
KNM(JNM)=NAMZ-2
C KNM GETS BACK +2 AT RETURN FROM RESPC.
JRD=JRD+1
NXX=NRD(JRD)
CZ NAME=0
CZ NAMZ=0
44 RSTAFF=0
13 YN=0
IF(SN.NE.200)GO TO 8
YN=-1
IF(YCLEF.GT.1)YCLEF=-1
IF(YSIG.GT.1)YSIG=-1
IF(YMTR.GT.1)YMTR=-1
8 ZLFT=XLFT+.5
RNUM=PGNUM
C SIZE FACTOR FOR PAGE NUMBER FINDER (MAYBE).
RLFT=RLFT-3
C TO CATCH 1ST SLURS.
JCUE=0
IF(LK.EQ.1)GO TO 2112
CX DO 3112 K=1,LK
CX3112 Q(K)=SAVES(K)
CALL RLOOP(Q,SAVES,LK)
C PUTS SAVED THINGS INTO Q ARRAY AND POINTER ARRAY (KPN)
CX DO 4112 K=2,LLL
CX4112 KPN(K)=KSAVE(K)
CALL RLOOP(KPN,KSAVE,LLL)
KPN(1)=1
C THIS SECTION COLLECTS ALL ITEMS TO USED LATER(NOT EVERYTHING IF 'PARTS')
2112 DO 6 K=1,ITEM
R5=-1
R=CODEN(KWDS,K,RN,J)
IF(R.EQ.0)GO TO 6
C DUPLICATE BARS WERE CHANGED TO CODE 0
RWD=RN(J)
C RWD IS WDCNT OF EACH ITEM
800 IF(R.NE.4)GO TO 80
IF(RN(J+4).GE.1000)GO TO 801
C FINDS DBL BARS OF ALL SORTS
IF(RWD.GT.2)GO TO 182
C FOUND A BAR LINE
801 IF(RN(J+3).LT.ZLFT)GO TO 6
C DROPS BAR LINE AT LEFT OF STAFF.
IF(IPG.EQ.0)GO TO 382
IF(RWD.LT.2)GO TO 382
LL=RN(J+4)/100.
RR=100*LL+1.0
RN(J+4)=RR
C THIS PRESERVES DOUBLE BARS OF ALL SORTS.
CCC IF(RN(J+2).NE.0)GO TO 182
C KEEP BAR LINES ON STAVES >0 BUT DON'T COUNT THEM.
382 CALL DBAR(K,ITEM,J)
IF(YN.EQ.0)GO TO 810
CALL ADRST(KPN,RR)
GO TO 6
182 RN(J+1)=44
C CHANGES CODE NUM
IF(IPG.EQ.0)GO TO 482
IF(RN(J+5).EQ.150)RN(J+2)=SN
C P5=150=PUT CRESC-DECRESC. IN ALL PARTS (WHEN IN PARTS MODE [IPG=-1])
482 IF(RWD.LT.5)GO TO 80
IF(RN(J+7).GE.3)GO TO 6
C SKIP HEAVY BRACKETS.
IF(RWD.LT.4)GO TO 80
A=RN(J+6)
IF(A.EQ.0)GO TO 80
IF(A.GE.199)RN(J+6)=200
80 IF(R.NE.16)GO TO 180
IF(RWD.LT.8)GO TO 280
IF(RN(J+10).EQ.1)RN(J+3)=RN(KWDS(K-1)+3)
C PUT CONTINUATION OF TEXT IN SAME POS. AS 1ST UNIT OF TEXT.
280 IF(IPG.EQ.0)GO TO 180
IF(RN(J+5).GE.100)RN(J+2)=SN
C CATCHES WANTED TEXT ON OTHER LINES. (P5>100)
CXXX IF(RN(J+5).GT.RLTRSZ)RN(J+5)=RLTRSZ
C LIMITS SIZE OF LETTERS. ADJUST RLTRSZ TO SUIT. (SET AT 1.0 NOW)
180 RSN=RN(J+2)
IF(IPG.LT.0)GO TO 2011
ISN=RSN
RSN=SN
C THE STAFF NUM.
2011 IF(R.NE.3)GO TO 3801
IF(IPG.LT.0)GO TO 2111
CLEF=RCL(ISN)
GO TO 4801
2111 IF(RN(J+6).LT.100)GO TO 4804
RN(J+2)=SN
C SIZE +100 (R6) IS PUT IN ALL PARTS (FOR P,PP,PPP,MF, ETC.)
GO TO 4803
4804 IF(YCLEF)GO TO 4801
IF(RSN.NE.SN)GO TO 6
4801 RR=CLEFN(RN,J)
C GET CLEF NUMBER.
IF(RR.EQ.CLEF)GO TO 6
C SKIP DUPLICATE CLEFS.
IF(RR.GT.4)GO TO 4800
C 0=TREB 1=BASS 2=ALTO 3=TENOR 4=PERCUSSION CLEF.
IF(IPG.LT.0)GO TO 17
RCL(ISN)=RR
IF(RCLEF(ISN).EQ.99)RCLEF(ISN)=RR
C SAVE FIRST CLEF ON EACH STAFF
GO TO 1800
CP16 FORMAT(' CLEF=',F2.0,' --CHANGE TO--',$)
CP TYPE 16,RR
CP ACCEPT 5,RR
17 R5=RR
CLEF=RR
YCLEF=0
GO TO 1800
4800 IF(RSN.NE.SN)GO TO 6
4803 RN(J+1)=33
GO TO 1800
4802 YCLEF=0
C CATCHES CLEF AFTER FIRST RESTS.
GO TO 6
3801 IF(R.NE.17)GO TO 3800
CCX IF(IPG)GO TO 2211
IF(IPG.EQ.0)GO TO 3802
CCX XSIG=RSIG(ISN)
CCX GO TO 3802
2211 IF(YSIG)GO TO 3802
IF(RSN.NE.SN)GO TO 6
3802 RR=RN(J+5)
CCX IF(RR.EQ.XSIG)GO TO 6
IF(RR.EQ.RSIG(ISN))GO TO 6
YSIG=0
CCX XSIG=RR
C SKIPS DUPL. KEY SIGS. ***** DO I NEED THIS??
IF(RSIG(ISN).EQ.99)RSIG(ISN)=RR
C SETS UP KSIG ONCE ONLY.
CC IF(IPG.EQ.0)RSIG(ISN)=RR
GO TO 1800
C**** OR↑↑↑↑ GO TO 81 ???***
3800 IF(R.EQ.8)GO TO 6
C OMIT ALL STAVES FOR NOW
IF(R.NE.18.)GO TO 81
CP IF(IPG)GO TO 2311
XMTR=RMETER(ISN)
GO TO 1801
2311 IF(YMTR)GO TO 1801
IF(SNMTR.EQ.200.)SNMTR=RSN
C SO IT WON'T REPEAT METERS.
C CHECK ALL METERS IF LINE HAS NOT THIS INST.
IF(RSN.NE.SNMTR)GO TO 6
1801 RA=TSIG(RN,J)
C THE TIME SIG.
IF(XMTR.EQ.RA)GO TO 6
XSIG=RA
XMTR=RA
YMTR=0
IF(IPG.LT.0)GO TO 181
RMETER(ISN)=RA
GO TO 1800
181 RR=RN(J+3)
DO 281 LS=1,LLL-1
IF(CODEN(KPN,LS,Q,KW).NE.R)GO TO 281
C LOOK FOR SAME METER CLOSE TO SAME POS. (DIF. METER WILL OVERPRINT)
IF(XSIG.NE.TSIG(Q,KW))GO TO 281
IF(ABS(Q(KW+3)-RR).LT.0.5)GO TO 6
281 CONTINUE
GO TO 1800
81 IF(RSN.NE.SN)GO TO 6
1800 IF(IPG.EQ.0)GO TO 5800
IF(RN(J+3).LT.XLFT)GO TO 6
C OMIT SOME THINGS TO LEFT OF STAFF BEGINNING.
GO TO 6800
5800 IF(R.NE.7)GO TO 282
6800 IF(R.LT.4)GO TO 810
IF(R.EQ.44)GO TO 6801
IF(R.GT.7)GO TO 810
C NEXT FOR ITEMS WHERE P6 MAY GO PAST 200.
IF(RWD.LT.5)GO TO 810
6801 A=ABS(RN(J+7))
IF(A.LT.2.OR.A.GT.7)GO TO 82
C CATCHES TRILL WIGGLE OVER END OF LINE.
282 IF(R.NE.5)GO TO 810
IF(RN(J+3).LT.RLFT)GO TO 6
C OMIT ENTERING SLURS. NEXT CHECKS FOR SLUR OVER END OF LINE
82 IF(RN(J+6).GE.199.)RN(J+6)=200.
C ****** 200.0 ABOVE IS SUBJECT TO CHANGE!
810 KL=0
CC IF(R.GT.2)GO TO 1810
IF(R.EQ.1)GO TO 2810
IF(R.NE.2)GO TO 1810
IF(IPG.GE.0)GO TO 2810
IF(RWD.LT.8)GO TO 2810
C NEXT FOR FINDING CUES WHEN IN PARTS MODE. FINALLY GETS LAST NEEDED POINTER.
IF(RN(J+10).GE.0)JCUE=K
C NEXTS FINDS NOTES AND RESTS WITHOUT RHYTHM (P7 OR P9)
2810 IF(RN(J+3)-PQ.GT.SPCPG)GO TO 1810
C JUMP IF NOT IN SAME VERT. POS.
IF(RT.NE.R)GO TO 1810
C JUMP IF PREVIOUS ITEM WASN'T THE SAME
CC IF(RN(J+9).NE.4.0/88.0)GO TO 3810
C JUMP IF NOT A GRACE NOTE
CC R=0
C R=0 SO THAT GRACE NOTE WILL NEVER BE TOO CLOSE TO REG. NOTE.
CC GO TO 1810
3810 RS=9-R*2
IF(RWD.GE.RS)GO TO 1810
C JUMP IF WDCNT IS BIG ENOUGH
KL=RS-RWD
C SEND THE DIFFERENCE TO THE SUBROUTINE AND ADD A RHYTHM (1.0)
1810 IF(IPG.LT.0)RN(J+2)=0
C ALWAYS SET STAFF NUM TO 0 FOR PARTS.
CALL QRN(J,KPN,K)
C PUTS NEEDED THINGS INTO Q ARRAY
RT=R
PQ=RN(J+3)
C SAVE THINGS FOR NEXT TIME AROUND LOOP.
6 CONTINUE
IF(JCUE.NE.0)CALL CUES
C******↓↓↓↓↓↓ RHYTH RESET ↓↓↓↓↓↓↓↓
CALL SORT(KPN)
C SORTS Q ARRAY, PUTS IT BACK INTO RN
23 LL=0
C TO 'MOVE' INSTEAD OF 'JUSTIFY'
CC J=1
CC223 R=CODEN(KWDS,J,RN,K)
CC IF(R.LE.3.OR.R.EQ.17.OR.R.EQ.18)GO TO 123
CC J=J+1
CC GO TO 223
CC123 R8=ENDLN-RN(K+3)+2
CC R4=0
CC R7=0
CC RS=0
CC R9=0
CC R5=10000
C INSERT?? →→ IF(R8.GT.0)R9=200.
CC33 CALL PTMOVE(RN,KWDS)
C******* IS KQ SUPPOSED TO BE 0!!!!!!!!?????
CALL SHFT0(KQ)
20 CALL RESPC
KNM(JNM)=KNM(JNM)+2
C UPDATE THE FILE NAME
GO TO 1344
END
SUBROUTINE READX(IDEV,NAME,IEXT,KEND,NUMS)
COMMON /PTR/INP(72)
DIMENSION FORM2(5),FORMT(5),NUMS(30)
DATA FORMT(1)/'('/,FORM2/'A1,','A2,','A3,','A4,','A5,'/
1, FORM3/'30I)'/
1 FORMAT(72A1)
CC IEXT='DMD'
CC ACCEPT 1,INP
KEND=0
C IDEV=DEVICE NUMBER (1=DSK, 5=TTY)
READ(IDEV,1,END=12)INP
DO 2 K=2,72
IF(INP(K).EQ.' ')GO TO 3
2 IF(INP(K).EQ.'.')GO TO 4
3 FORMT(3)=FORM3
FORMT(4)=' '
FORMT(5)=' '
5 FORMT(2)=FORM2(K-1)
REREAD FORMT,NAME,NUMS
GO TO 10
4 FORMT(3)=FORM2(1)
C CATCHES DOT
DO 7 N=K+1,72
7 IF(INP(N).EQ.' ')GO TO 8
8 FORMT(4)=FORM2(N-K-1)
FORMT(5)=FORM3
FORMT(2)=FORM2(K-1)
REREAD FORMT,NAME,K,IEXT,NUMS
CALL LO2UP(IEXT)
10 CALL LO2UP(NAME)
RETURN
12 KEND=-1
END
SUBROUTINE LO2UP(J)
C CONVERTS ALL LOWER CASE TO UPPER CASE.
J=J.AND..NOT.((J/2).AND."201004020100)
END
FUNCTION TSIG(Q,J)
DIMENSION Q(1)
TSIG=IFIX(Q(J+5)*100.0+Q(J+6)+.5)
C COMBINES METER NUMS. (2/4 = 204. ETC.)
END
SUBROUTINE RESPC
COMMON/STF/RSTFAC(8),RSTJ2 /POSI/STFF(8),JJ2,JPQ
1 /IPG/IPG,JPG,BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),
1 RCLEF(0/7) /IVV/IV(1)
COMMON RS,JA,REST,J2,RQ(18),JX,PR,LX,RDIS
C ORDER OF COMMON BLOCKS **MUST** STAY AS IS!
COMMON/XRN/RN(1) /SF/KL,RT,KP,STFSZ,NAMX
1 /PTR/KWDS(1)/LLL/L,LL,I,IX/XXX/LK,LP,JY /JN/J,N
C INCREASE DIMENSION OF KWDS FOR VERY FULL PAGES.
DIMENSION NRD(100),MM(1500),NN(1500),BARS(509),E(100),F(100),
1 G(100),H(100),KPN(1),HH(100),HHH(100),DUMMY(100),PGTRN(500)
INTEGER DUMMY
COMMON /PX/PN(1) /Q/Q(1)
1 /RCLF/KK,CLEF,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,RNAM3
1 /KBAR/KBAR(1) /RSP/KNM(1) /ENDL/ENDLN,KQ,NAME,NMPG,SPCNT
DATA FIB/.8/ ,RSPC/28./,PGNUM/1.6/,RNMHT/16.0/,RNMSZ/1.2/
1 ,RLTRSZ/1.0/,SPCPG/2.7/,SPCRX/1.5/ ,BFAC/0.7/,ACCISZ/1.0/
C RSPC=28 SEEMS TO BE ARBITRARY. SPCRX USED IN RHYTH RESPACE.
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5)),(MM,RN)
1,(NN,RN(501)),(KPN,PN),(KS,RS),(BARS,KBAR(4)),(HHH,RN(2250))
1,(R8,RQ(6)),(R9,RQ(7)),(RQ(10),XLFT),(KBR,KBAR),(T,KBAR(2))
1,(LASTNM,KBAR(3)),(LCNT,IV(45)),(NDPY,IV(46)),(HH,RN(1250))
1,(E,RN(1000)),(F,RN(2500)),(G,RN(2700)),(H,RN(2850))
1,(DUMMY,RN(1400)),(PGTRN(1),KBAR(516))
C RQ(2) IS R4, RQ(3) IS R5 ETC.
IF(NMPG.NE.'PAGEA')GO TO 2000
C SHOULD HANDLE UP TO 104 INPUT FILES. ADD HERE AND LATER FOR MORE RANGE.
RNEXT=0
2000 SPCNT=1.0
JX=0
JCEN=0
C FLAG FOR CENTERED RESTS.
XT=0
JK=1
C JK IS USED AT END. IN SECTION TO FIND SIZE FACTOR FOR EACH BAR.
PX=0
CALL SHFT1(KQ)
KK=L
CC TYPE 3001,L
C DELETES EXTRA BAR LINES, ETC.
IF(IPG)CALL RESTS
C??? IF(N)RETURN
C N IS NEG., ONLY RESTS WERE ON THIS LINE. (WHAT ABOUT LAST LINE???)
C FROM NOW ON ALL CODES #-1 ARE IGNORED, RESTS HAVE BEEN COMBINED.
CALL SHIFT
C L=NUMBER OF ITEMS FOR RHY RECONS.
JJ2=L+2
C FOR WDCNT IN .PAG FILE
IF(IPG.EQ.2)GO TO 11
C IPG=2=REORDER INPUT FILE ONLY.
N=0
S=-100
R=0
KCLEF=0
NOGRCE=-1
C GRACE NOTE FLAG
TTT=0
C FOR IRREG. NUMS. OF STAVES.
C******** BIG LOOP ***************
161 DO 601 K=1,L
R=CODEN(KPN,K,Q,J)
RZ=Q(J)
CX J=KPN(K)
CC N=N+1
CC NN(N)=0
CC MM(N)=J+3
CALL MMNN(3)
NN(N)=-R
C MAKE ALL CODE NUMS NEG. AT FIRST. CHANGE 1,2,3,4,17,18 LATER
CX R=Q(J+1)
IF(R.GT.2)GO TO 1801
IF(Q(J+2).GT.TTT)TTT=Q(J+2)
C FINDS HIGHEST STAFF NUM. NOW WE CAN HAVE IRREG. NUMS. OF STAVES.
IF(R.NE.1)GO TO 2801
IF(RZ.LT.7)GO TO 601
IF(Q(J+9).LE.0)GO TO 601
C P9=-1 FOR NOTES WITHOUT LEDGER LINES (HENCE NO RHYTHM.)
IF(Q(J+9).NE.4./88.)GO TO 702
CC IF(Q(J+9).GT..05)GO TO 702
CC IF(Q(J+8).EQ.1000)GO TO 601
C SKIP GRACE NOTE, OR NOTES WITHOUT RHY., OR .LT.1/88 NOTES.
NOGRCE=0
GO TO 601
CCC2801 IF(R.NE.2)GO TO 1801
2801 RS=Q(J+7)
IF(RZ.LT.7)GO TO 3801
C DELETE ALL UP TO LABEL 1801 LATER. NEW CENTERED REST FEATURE. 5/29/78
CXX NN(N)=-NN(N)
IF(Q(J+9).NE.0)Q(J+9)=-1
C SET UP WHOLE REST CENTERING. (P9=-1 CAUSES CENTERING AT OUTPUT TIME.)
IF(Q(J+8).EQ.0)GO TO 601
C SKIP IF WHOLE REST OVER CUE NOTES. (P8=0)
IF(RS.LE.0)GO TO 601
C SKIP RESTS WITH NO RHYTHM VALUE IN P7
GO TO 702
C??? NOW MAKE CODE NUM. POS.
CC NN(N)=R
CC GO TO 688
3801 IF(RZ.LT.5)GO TO 601
IF(RS.LE.0)GO TO 601
IF(IPG)GO TO 702
IF(RZ.LT.6)GO TO 702
IF(Q(J+6))GO TO 702
C PARAM 6=-1 = INVISIBLE. SHOULDN'T BE WHOLE REST (P8) ANYWAY.
RS=Q(J+3)
C GET POS. OF CENTERED WHOLE REST
TT=0
B=Q(J+2)
C GET THE STAFF NUM.
DO 602 M=1,L
T=CODEN(KPN,M,Q,JJ)
A=Q(JJ+3)
C GET POS. OF ITEM
IF(A.GT.RS)GO TO 602
C JUMP IF ITEM IS TO RIGHT OF REST
IF(T.NE.4)GO TO 602
C IS THE ITEM A BAR LINE
IF(A.GT.TT)TT=A
C FINDS BAR LINE CLOSEST TO LEFT OF REST
602 CONTINUE
C NOW T HAS POS OF CLOSEST BAR, KSIG OR METER TO LEFT OF REST
T=20000
A=20000
C NOW FIND NOTE OR REST CLOSEST TO RIGHT OF BAR, ETC.
DO 613 M=1,L
IF(CODEN(KPN,M,Q,JJ).GT.2)GO TO 613
IF(Q(JJ).LT.7)GO TO 609
C SKIP IF RHYTH NOT IN P9
IF(Q(JJ+9).LT..05)GO TO 613
C IGNORES GRACE NOTES. ****** THERE COULD BE SOME RARE PROBLEMS HERE *****
609 B=Q(JJ+3)
C POS. OF ITEM
X=B-TT
IF(X)GO TO 613
C JUMP IF ITEM IS TOO FAR TO LEFT
IF(X.GT.A)GO TO 613
A=X
T=B
C T = POS OF NOTE OR REST NEAREST BAR, ETC.
613 CONTINUE
IF(T.NE.20000)GO TO 612
C JUMP IF NOTE OR REST FOUND
JCEN=-1
GO TO 1801
612 Q(J+3)=T
C THE REST IS NOW MOVED NEAR TO BAR, PROPER POS.
C MUST ALIGN REST WITH FIRST RHYTH ON OTHER STAFF.
C THIS WILL IGNORE WHOLE RESTS IN CENTER OF MEASURE.
1801 IF(R.LT.4)GO TO 702
IF(R.EQ.17)GO TO 1702
IF(R.EQ.18)GO TO 1702
IF(R.EQ.10)GO TO 702
C FOUND A NUMBER. USE THIS IN RESTP
IF(R.LE.7)GO TO 30
IF(R.NE.44)GO TO 601
IF(RZ.EQ.2)GO TO 601
C RZ=2= BAR LINE ON UPPER STAFF
IF(Q(J+6).EQ.0)GO TO 601
IF(Q(J+5).EQ.0)GO TO 601
C GETS LEFT END OF LINES, CRESC., DASHES.
GO TO 604
30 IF(R.NE.7)GO TO 605
IF(RZ.LT.5)GO TO 604
C JUMP FOR STANDARD TRILL
RS=Q(J+7)
IF(RS.EQ.1)GO TO 604
IF(ABS(RS).GE.3)GO TO 604
C JUMP FOR 8VA, 15MA, ELSE THIS IS A PEDAL MARK WITHOUT LINE.
GO TO 601
605 IF(R.NE.4)GO TO 604
IF(RZ.LE.3)GO TO 702
C JUMP IF IT IS A BAR LINE
CC IF(RZ.LT.4)GO TO 601
IF(Q(J+6).NE.0)GO TO 604
C GO GET OTHER POS OF LINE
GO TO 601
1702 IF(Q(J+4).NE.0)GO TO 601
IF(Q(J+2).NE.0)GO TO 601
C IGNORE METER NOT IN VERT. POS. 0. (PUT IN OTHER PROGS!)
702 NN(N)=-NN(N)
CC702 NN(N)=R
GO TO 601
C NEXT FOR MULTIPOSITION ITEMS: LINES, SLURS, BEAMS, TRILL, 8VA
604 CALL MMNN(6)
C NEXT POS2, 3 AND 4 OF CERTAIN ITEMS (PUTS -1 INTO NN(X))
CCXX NN(N)=-1
IF(R.NE.6)GO TO 601
C NEXT FOR BEAMS
IF(RZ.LT.8)GO TO 608
IF(Q(J+10).EQ.0)GO TO 608
IF(Q(J+8))GO TO 608
C P8<0 = P8=P3 (PARTIAL BEAM TO LEFT)
IF(Q(J+7).GT.0)CALL MMNN(8)
C NEXT SHIFTS P8 OF COMPOSITE BEAMS
608 IF(RZ.LT.7)GO TO 601
IF(Q(J+7))GO TO 688
C P7 IS NEG FOR TREMOLO
IF(Q(J+8).EQ.0)GO TO 601
C P8 NEG OR POS = POS3 IN P9; P8=0= P9 IS NUM.
688 IF(Q(J+9).GT.0)CALL MMNN(9)
C FOUND A POS. IN P9
601 CONTINUE
KPG=TTT+1
C KPG IS CURRENT NUM. OF STAVES. (ALWAYS START AT STAFF 0!!!!)
C NEXT SORTS THE POINTS
6000 J=1
CC610 IF(NN(J).NE.-16)GO TO 1610
C NEXT LOOKS FOR CONTINUATION OF TEXTS.(P10=1) PUTS ALL AT SAME P3 LOC.
CC K=MM(J)
CC IF(Q(K-3).LT.8)GO TO 1610
CC IF(Q(K+7).EQ.1)Q(K)=Q(MM(J-1))
CC GO TO 710
CC1610 IF(Q(MM(J)).LE.Q(MM(J+1)))GO TO 710
610 IF(Q(MM(J)).LE.Q(MM(J+1)))GO TO 710
CALL EXCHG(MM(J),NN(J))
C ABOVE EXCHGS --(J) AND --(J+1)
IF(J.EQ.1)GO TO 710
J=J-1
GO TO 610
710 J=J+1
IF(J.LT.N)GO TO 610
C NOW ALL SORTED
CALL FNDEND(R)
CALL SHFTQ(R)
C SHIFTS TO PROPER HORIZ. POS.
IF(IPG)CALL RESTP
C RESTP COMBINES LEFTOVER NUMBERED BARS OF RESTS. (FOR PARTS ONLY)
IF(N.LE.0)GO TO 122
C N IS NEG IF ONLY RESTS ON THIS LINE. GO BACK.
DO 119 K=1,150
119 HH(K)=0
C HH ARRAY WILL HOLD FINAL COMPOSITE.
G(1)=0
E(1)=0
F(1)=0
RN(1500)=0
RN(2500)=0
ST=0
C ST=STAFF NUM, T=TOTAL RHYTHMS, J=CNTR OF MAIN POS. ARRAY
C JJ=CNTR FOR 2ND POS. ARRAY, JJJ=CNTR FOR 3RD.
KE=0
J=1000
933 JJ=1500
JJJ=2000
T=0
M=0
A=0
B=0
DO 33 K=1,N
IF(NORH(KK))GO TO 33
CC KK=NN(K)
CC IF(KK.EQ.0)GO TO 33
CC IF(KK.EQ.4)GO TO 2133
CC IF(KK.EQ.17)GO TO 2133
C SKIP OVER STAFF # TRAP WITH BARS, METER, KSIG.
CC IF(KK.EQ.18)GO TO 2133
CC IF(KK.GT.2)GO TO 33
2133 LL=MM(K)-3
IF(KK.LE.2)GO TO 1133
RH=.01
C RHYTHMIC VALUE OF BARLINE, METER, KSIG
CCC IF(KK.NE.4)RH=.6
GO TO 3133
1133 IF(Q(LL+2).NE.ST)GO TO 33
C JUMP IF NOT ON RIGHT STAFF
RA=9
IF(KK.EQ.2)RA=7
IF(Q(LL).LT.RA-2)GO TO 33
C JUMP IF WDCNT IS TOO SHORT
IF(KK.EQ.1)GO TO 433
IF(Q(LL).LT.6)GO TO 433
C NEXT FOR NUMBERED RESTS - SETS RHYTH VALUE BASED ON NUMBER.
RZ=Q(LL+8)
C IF >0, RZ =THE NUMBER, ELSE IT'S A WHOLE REST, CENTERED, ETC.
IF(RZ.LE.0)GO TO 433
Q(LL+7)=2
C 2 IS THE SMALLEST RHYTH VALUE FOR A NUMBERED REST (WAS 3)
IF(RZ.LT.8)GO TO 433
Q(LL+5)=-3
C IF NUMB. .GE.8 THEN PRINTS DBL WHOLE REST
RZ=RZ/2.0
CC RZ=IFIX(RZ/2.0)+1.0
IF(RZ.GT.6)RZ=6
C LIMIT OF 8 ON RHYTH VAL.
Q(LL+7)=RZ
433 RH=Q(LL+IFIX(RA))
IF(RH.EQ.0)GO TO 33
3133 RZ=Q(LL+3)
IF(ZERO(RZ,A).EQ.0)GO TO 133
C JUMP IF THIS NOTE IN SAME POS. AS LAST ONE.
RRH=RH
C SAVE RHYTH TO CHECK WITH OTHER IN SAME POS.
TT=T
C SAVE TOTAL RHYTHM BEFORE THIS NOTE.
J=J+1
C UPDATE COUNTER IN POSITION ARRAY
T=T+RH
C ADD TO TOTAL RHYTHM
RN(J)=T
A=Q(LL+3)
C SAVE POS. OF THIS NOTE.
GO TO 33
133 IF(RH.EQ.RHH)GO TO 33
C IGNORE 2ND RHYTH IF SAME AS FIRST
IF(ZERO(RZ,B).EQ.0)GO TO 333
C JUMP IF A THIRD DIFFERENT RHYTHM IN SAME POS. (THIS IS THE LIMIT!)
TTT=TT
C SAVE TOTAL RHYTHM TO THIS POINT.
TT=TT+RH
JJ=JJ+1
C UPDATE COUNTER FOR 2ND ARRAY
RN(JJ)=TT
RRRH=RH
B=A
GO TO 33
333 IF(RH.EQ.RRRH)GO TO 33
TTT=TTT+RH
JJJ=JJJ+1
RN(JJJ)=TTT
33 CONTINUE
C NOW COMPARE THIS WITH BASIC RHYTHM ARRAY (STARTS AT RN(1001)
IF(ST.NE.0)GO TO 733
KE=J-999
C TOTAL NUM OF RHYTHMS ON STAFF1.
CC IF(JPG.EQ.0)GO TO 2233
IF(KPG.LE.1)GO TO 2233
C KPG=0=PARTS; =1=PAGE, 1 STAFF
C JUMP IF ONLY ONE STAFF
C****733 KF=J-2499
C KF=NUM OF RHYTHMS ON NEXT STAFF. **** NEVER USED ****
733 ST=ST+1
IF(ST.GT.1)GO TO 833
C JUMP IF ALL STAVES HAVE BEEN READ.
1233 J=2500
GO TO 933
833 IF(J.NE.2500)GO TO 1533
C JUMP IF THERE IS ONLY ONE LINE OF RHYTHM
C NOW LINE ONE STARTS AT RN(1001), LINE 2 AT RN(2501)
2233 CALL RLOOP(HH,E,KE)
C FOR SINGLE STAFF OF RHYTHM
KL=KE
GO TO 1333
1533 K=1
L=1
M=0
19 KK=K
LL=L
1 SM=10000
K=K+1
IF(K.GT.KE)GO TO 10
4 L=L+1
Y=F(L)
B=Y-F(L-1)
IF(B.LT.SM)SM=B
2 X=E(K)
A=X-E(K-1)
C A AND B HAVE TRUE DURATIONS NOW
IF(A.LT.SM)SM=A
C SM = SMALLEST RHYTH VALUE BEFORE NEXT CONTACT
IF(ZERO(X,Y).EQ.0)GO TO 3
C JUMP IF EQUAL RHYTHS
IF(X.GT.Y)GO TO 4
K=K+1
C STEP FORWARD UNTIL X IS .GT. Y
GO TO 2
3 IF(K.NE.KK+1)GO TO 13
IF(L.NE.LL+1)GO TO 14
M=M+1
G(M)=E(KK)
GO TO 19
13 IF(L.NE.LL+1)GO TO 15
DO 16 J=KK,K-1
M=M+1
16 G(M)=E(J)
GO TO 19
14 DO 17 J=LL,L-1
M=M+1
17 G(M)=F(J)
GO TO 19
15 XM=SM-.001
M=M+1
P=E(KK)
G(M)=P
7 KK=KK+1
LL=LL+1
YM=SM*1.5
C THIS COULD BE *2 (NOTE /16/8./ VS. /6/12/ )
S=P
T=P
27 A=E(KK)
B=F(LL)
IF(ZERO(A,B).EQ.0)GO TO 19
X=ZERO(A,P)
Y=ZERO(B,P)
C FUNCT. ZERO: ZERO=B-P, IF(ABS(ZERO).LT..01)ZERO=0
S=E(KK-1)
T=F(LL-1)
9 IF(A-S.LT.X-.01)X=ZERO(A,S)
IF(B-T.LT.Y-.01)Y=ZERO(B,T)
IF(A.GT.B+.01)GO TO 8
B=A
KK=KK+1
62 IF(X.GT.YM)GO TO 5
IF(X.EQ.0)GO TO 27
P=P+SM
25 M=M+1
G(M)=P
GO TO 27
5 P=P+SM
IF(P)GO TO 203
C IF(P)ERROR
IF(P.LT.B-.01)GO TO 5
GO TO 25
8 X=Y
LL=LL+1
GO TO 62
10 M=M+1
G(M)=E(KE)
CC TYPE 410,(E(K),K=1,KE)
CC TYPE 410,(F(K),K=1,KF)
CC TYPE 410,(G(K),K=1,M)
CBCB WRITE(21,410)(E(K),K=1,KE)
CB WRITE(21,410)(F(K),K=1,KF)
CB WRITE(21,410)(G(K),K=1,M)
410 FORMAT(10F7.2)
C NEXT SECTION SETS UP COMPLETE RHYTH COMPOSITE(NEGS. OR NON-SPC VALS.)
1033 JJ=1
H(1)=0
J=1
K=2
L=2
511 IF(J.EQ.M)GO TO 911
J=J+1
X=G(J)
1211 A=E(K)
B=F(L)
Y=ZERO(X,A)
Z=ZERO(X,B)
IF(A-B.GT..01)GO TO 1111
IF(Y.EQ.0)GO TO 1311
IF(X.LT.A-.01)GO TO 1111
K=K+1
1411 JJ=JJ+1
H(JJ)=-A
GO TO 1211
1111 IF(Z.EQ.0)GO TO 1311
IF(X.LT.B-.01)GO TO 1311
L=L+1
A=B
GO TO 1411
1311 JJ=JJ+1
H(JJ)=X
IF(Y.EQ.0)GO TO 611
IF(Z.EQ.0)GO TO 711
IF(ZERO(A,B).EQ.0)GO TO 511
P=A
IF(P.GT.B+.01)GO TO 811
IF(P.GT.X+.01)GO TO 511
K=K+1
GO TO 1011
811 P=B
IF(P.GT.X+.01)GO TO 511
L=L+1
1011 JJ=JJ+1
H(JJ)=-P
C NON-SPACED RHYTHS ARE NEG.
GO TO 511
611 K=K+1
IF(Z.GT.0)GO TO 511
711 L=L+1
GO TO 511
911 IF(HH(2).EQ.0)GO TO 2011
K=2
J=2
L=1
HHH(1)=0
1511 IF(J.GT.JJ)GO TO 1811
P=H(J)
A=ABS(P)
B=ABS(HH(K))
IF(ZERO(B,A).EQ.0)GO TO 1611
IF(A.GT.B)GO TO 1711
J=J+1
GO TO 1911
1711 P=HH(K)
GO TO 2211
1611 J=J+1
2211 K=K+1
1911 L=L+1
HHH(L)=P
GO TO 1511
2011 CALL RLOOP(HH,H,JJ)
KL=JJ
GO TO 2111
1811 CALL RLOOP(HH,HHH,L)
KL=L
2111 IF(ST.GE.KPG)GO TO 1333
CALL RLOOP(E,G,M)
KE=M
C GO WAY BACK AND READ ANOTHER LINE.
GO TO 1233
1333 E(1)=0
GO TO 2333
TYPE 410,(HH(K),K=1,KL)
WRITE(21,410)(HH(K),K=1,KL)
2333 JD=1
C JD IS COUNTER FOR DUMMY POSITIONS.
DUMMY(1)=1
ST=0
183 B=0
LL=2
DO 181 K=1,N
IF(NORH(L))GO TO 181
C LOOK FOR DUMMY RHYTHMS.
IF(L.LE.2)GO TO 2184
RZ=.01
C RHYTHMIC VALUE OF BAR, METER, KSIG. CHANGED TO ABS. SIZE LATER.
GO TO 1184
2184 LF=MM(K)
IF(Q(LF-1).NE.ST)GO TO 181
C FOUND RHYTH ON RIGHT STAFF (LF PNTS TO PARAM 3)
J=6
IF(L.EQ.2)J=4
RZ=Q(LF+J)
1184 B=B+RZ
184 V=ABS(HH(LL))
IF(ZERO(B,V).GT.0)GO TO 182
C FOUND RHYTH MATCH
JD=JD+1
DUMMY(JD)=LL
LL=LL+1
GO TO 181
182 IF(B.LT.V-.01)GO TO 181
LL=LL+1
GO TO 184
181 CONTINUE
ST=ST+1
IF(ST.LT.KPG)GO TO 183
C NEXT SORT DUMMY ARRAY
J=0
185 DO 186 K=2,JD
IF(DUMMY(K).NE.DUMMY(K-1))GO TO 187
DO 188 LL=K,JD
188 DUMMY(LL-1)=DUMMY(LL)
JD=JD-1
GO TO 185
187 IF(DUMMY(K).GT.DUMMY(K-1))GO TO 186
CALL EXCH(DUMMY(K),DUMMY(K-1))
GO TO 185
186 CONTINUE
C NOW DUMMY CONTAINS ALL NON-DUMMY RHYTHS!!!
PX=0
LF=0
K=1
V=0
81 K=K+1
IF(K.GT.KL)GO TO 1433
B=HH(K)
A=B-V
V=B
IF(V)GO TO 82
85 W=V
IF(A.GT.0.01)GO TO 89
C .GT. BECAUSE OF ROUND-OFF ERROR
T=5
IF(HH(K+1)-V.LE.0.01)T=2
PX=PX+T
C THIS FOR BARS, KSIG, METER
GO TO 189
89 PX=PX+14.0*EXP(ALOG(A)*0.5849624)
C THIS IS EXP((ALOG(A)/ALOG(2.0))*ALOG(1.5)) NOT FIBBONACI (1.618)
CC89 PX=PX+PFIBX(A)
189 E(K)=PX
IF(LF.NE.0)GO TO 86
GO TO 81
82 LF=K
83 K=K+1
V=HH(K)
IF(V)GO TO 83
A=V-W
GO TO 85
86 LL=LF-1
D=E(K)-E(LL)
87 S=-HH(LF)-HH(LL)
T=HH(K)-HH(LL)
T=S/T
C THIS FINDS POS OF NON-IMPORTANT RHY BETWEEN IMPORTANT ONES.
E(LF)=E(LL)+D*T
LF=LF+1
IF(LF.NE.K)GO TO 87
LF=0
GO TO 81
1433 GO TO 2433
TYPE 410,(E(K),K=1,KL)
WRITE(21,410)(E(K),K=1,KL)
C 5 IS SPACE AFTER 1ST BARLINE
2433 IF(Q(2).EQ.18)RNEXT=RNEXT-3.6
C PUSH CLOSER TO PREVIOUS BARLINE IF 1ST ITEM IS METER
R8=RNEXT
C POS OF 1ST BAR = END OF PREV. LINE
IF(ENDLN.EQ.0)RNEXT=9
C MAKES ROOM FOR 1ST CLEF.
KL=KL-1
J=0
R5=0
KK=1
JD=1
W=0
LF=0
DO 80 K=1,N
IF(NORH(L))GO TO 80
A=Q(MM(K))
IF(ZERO(A,W).EQ.0)GO TO 80
C SKIP IF SAME POS OF NOTE OR REST.
W=A
R7=R8
190 J=J+1
IF(J.LE.KL)GO TO 290
203 FORMAT(' FOUND CENTERED WHOLE REST!')
LL=0
IF(JCEN.GE.0)GO TO 220
TYPE 203
GO TO 121
220 JJJ=-1
L=0
120 W=LL
A=0
DO 124 K=1,N
LF=NN(K)
IF(LF.GT.2)GO TO 124
IF(LF.LE.0)GO TO 124
KE=MM(K)
IF(Q(KE-1).NE.W)GO TO 124
C ADD UP RHYTHMIC VALUES ON EACH SEPARATE LINE.
JD=6
IF(LF.EQ.2)JD=4
A=A+Q(KE+JD)
124 CONTINUE
TYPE 123,LL,A
LL=LL+1
IF(L.EQ.0)L=A*100.+.5
C SAVE NUM. OF BEATS FIRST TIME.
IF(L.NE.A*100.+.5)JJJ=0
C SET FLAG IF MISMATCH. (JJJ=0=MISMATCH, =-1=MISALIGNED)
IF(LL.LT.KPG)GO TO 120
IF(JJJ.NE.0)GO TO 121
JJJ=0
DO 320 K=2,JJ
A=HH(K)-HH(K-1)
IF(A.LE..01)GO TO 320
C SKIP BAR LINE VALUES (.01)
JJJ=JJJ+1
HH(JJJ)=4./A
C THIS WILL PRINT SMALLEST COMPOSITE RHYTHM
320 CONTINUE
TYPE 420,(HH(K),K=1,JJJ)
PAUSE
1' ****COMPOSITE RHYTHM ERROR - AND/OR MISALIGNED NOTES****'
GO TO 90
420 FORMAT(10F8.2)
123 FORMAT(' STF',I2,' =',F9.5,' QTRS')
121 PAUSE' *****RHYTHM MISMATCH*****'
GO TO 90
290 IF(DUMMY(JD).NE.J)GO TO 190
JD=JD+1
90 R8=RNEXT+E(J)
R4=R5
R5=A
X=(R8-R7)/(R5-R4)
S=R7-R4*X
DO 91 L=KK,K
LL=MM(L)
91 Q(LL)=S+X*Q(LL)
KK=K+1
80 CONTINUE
IF(KK.GT.K)GO TO 180
C THIS FOR ITEMS BEYOND LAST IMPORTANT ITEM.
R7=Q(LL)-R5
C R7=NEW POS. OF LAST IMPORTANT ITEM. R5=OLD POS.
DO 280 L=KK,K
LL=MM(L)
280 Q(LL)=R7+Q(LL)
180 JJ=JJ2-2
L=JJ2
M=0
C FLAG FOR REST AT START OF LINE
JJJ=-1
C FLAG FOR 1ST BAR OF LINE 12/77
V=0
ACCI=0
DO 12 J=1,JJ
R=CODEN(KPN,J,Q,LA)
CC IF(CODEN(KPN,J,Q,LA).NE.4)GO TO 12
IF(R.EQ.4)GO TO 680
IF(M)GO TO 780
IF(R.NE.2)GO TO 780
C NEXT FOR RESTS
ACCI=ACCI+.5
C ADD A LITTLE FOR TOTAL NUM. OF NOTES AND RESTS.
C SHOULD WE ALSO CONSIDER CLEFS?? MAYBE ADD LATER.
IF(KBR.EQ.0)GO TO 12
C LOOK FOR RESTS AT FRONT OF LINE.
X=0
CALL TURN(J,JJ,1,X)
PGTRN(KBR)=PGTRN(KBR)+X
M=-1
780 IF(R.NE.1)GO TO 12
IF(V.NE.Q(LA+3))GO TO 782
IF(JACC)GO TO 781
782 ACCI=ACCI+.5
IF(AMOD(Q(LA+5),10.0).EQ.0)GO TO 781
JACC=-1
V=1
C KPG=NUMB. OF STAVES BEING CONSIDERED. (IF 1, THEN ALL ACCIS ARE 'BIG')
IF(KPG.GT.1)V=RSTFAC(IFIX(Q(LA+2))+1)
CCCC V=RSTFAC(IFIX(Q(LA+2))+1)
CC ACCI=ACCI+ACCISZ*RSTFAC(IFIX(Q(LA+2)))
CCCC ACCI=ACCI+ACCISZ*V
ACCI=ACCI+V
C ADD SPACE FOR ACCIDENTALS*STAFF SIZE -- SEE DATA FOR ACCISZ.
V=Q(LA+3)
781 M=-1
IF(NOGRCE)GO TO 12
C NEXT TO GIVE EQUAL SPACE FOR EVERY GRACE NOTE
C FOUND A NOTE
C************************* IF(Q(LA+9).GT.0.05)GO TO 12
IF(Q(LA+9).NE.4.0/88.0)GO TO 12
C JUMP IF NOT A GRACE NOTE
R=Q(LA+2)
C THE STAFF NUM.
DO 580 LF=J+1,JJ
IF(CODEN(KPN,LF,Q,JD).NE.1)GO TO 580
IF(Q(JD+2).NE.R)GO TO 580
IF(Q(JD).LT.7)GO TO 580
IF(Q(JD+9).EQ.0)GO TO 580
C CHORD NOTE
R4=Q(LA+3)
CC R4=Q(LA+3)-1
R5=Q(JD+3)
C THE STAFF # IS IN R2
R8=RSTFAC(IFIX(R2+1))+.5
IF(Q(JD+4).LT.80)R8=R8*2
C INSURES SPACE BETWEEN GRACE NOTE AND NEXT NOTE
R8=R5-R8
CC R8=R5-R8-1
CCC IF(R4.EQ.R5)GO TO 12
IF(R4.NE.R5)GO TO 480
C GRACE NOTE AT START OF LINE ***** FIX THIS????
DO 880 KE=1,LF-1
880 Q(KPN(KE)+3)=R8
C MOVE THE GRACE NOTE, AND OTHER STUFF, TO LEFT.
GO TO 12
480 R2=Q(LA+2)
R9=R5
CALL PTMOVE(Q,KPN)
CC TYPE 9999,Q(J+3),Q(JD+3)
CC9999 FORMAT(2F)
GO TO 12
580 CONTINUE
GO TO 12
C ABOVE FOR GRACE NOTE SPACING.
680 KBR=KBR+1
C BAR LINE COUNTER
T=Q(LA+3)
C TOTAL SPACE
X=0
CALL TURN(J-1,1,-1,X)
CALL TURN(J+1,JJ,1,X)
222 PGTRN(KBR)=X
C FINDS PAGE-TURN POSSIBILITIES
C CHANGE ALL VALUES TO 4/5 OF THEIR CURRENT SIZE.
BFAC=.8
CCC BFAC=.756
IF(KPG.GT.1)CALL BARFAC(KPG,BFAC,JK)
CC IF(KPG.LE.1)GO TO 3112
C DO NEXT IF MORE THAN 1 STAFF(KPG) AND DIFF. SIZE FACTORS ARE FOUND.
CC R=RSTFAC(1)
CC DO 5112 K=2,KPG
CC5112 IF(R.NE.RSTFAC(K))GO TO 6112
CC GO TO 3112
C NEXT TO FIND PROBABLE SIZE FACTOR FOR THIS BAR. (NOT FOR PARTS)
C FIND LINE WITH MOST ACTIVITY.
C ALL THIS SORT OF WORKS. SOMEDAY REVIEW IT.********
CC6112 DO 1112 K=1,8
CC1112 RN(K)=0
CC DO 112 K=JK,J-1
CC R=CODEN(KPN,K,Q,JD)
CC IF(R.GT.3.)GO TO 112
CC A=1.0
C CHECKS FOR NUMBER OF NOTES, RESTS, CLEFS.
CC IF(R.EQ.2)A=0.6
C SKIP NON-RHYTHM CHORD NOTES. RESTS ARE CONSIDERED LESS IMPORTANT.
CC IF(R.NE.1)GO TO 4112
CC IF(Q(JD).LT.7)GO TO 112
CC IF(Q(JD+9).LE.0)GO TO 112
CC4112 LF=Q(JD+2)+1
CC RN(LF)=RN(LF)+A
CC112 CONTINUE
CC JD=1
CC B=RN(1)*RSTFAC(1)
CC DO 2112 K=2,8
CC A=RN(K)*RSTFAC(K)
CC IF(A.LE.B)GO TO 2112
CC JD=K
CC B=A
CC2112 CONTINUE
CC BFAC=BFAC*(RSTFAC(JD)+.1)
C +.1 ABOVE TO MINIMIZE DIFF. IN SIZE FACTOR.
CXX BFAC=.84*RSTFAC(JD)
3112 IF(JJJ)RNEXT=RNEXT-6
C JJJ=-1 IF 1ST BAR OF LINE. 12/77
JJJ=0
BARS(KBR)=(T-RNEXT+ACCI)*BFAC
C SIZE OF THIS MEASURE + ACCISZ*ACCIDENTALS
ACCI=0
C RESET ACCI (SPACE FOR ACCIS AND TOTAL NUM. OF NOTES)
K=J
JK=J+1
C SET UP POINTER FOR NEXT BAR'S ITEMS.
RNEXT=T
12 CONTINUE
IF(K.NE.JJ)RNEXT=Q(KPN(JJ)+3)
RNEXT=RNEXT+5
CCC 11/9/78 RNEXT=RNEXT+3
JJ2=L
C JJ2 GETS WIPED OUT IN PTMOVE, SO GET IT BACK HERE
CC???380 LCNT=0
CC??? NDPY=0
C JJ2 IS END OF PNTR DATA
11 IF(IPG.EQ.2)NMPG=NAMX
C IPG=2=REORDER INPUT FILE ONLY.
JPQ=KPN(JJ2-1)+1
CALL PUTEXT(NMPG,'PAG')
CALL EXTOUT(RSTFAC,128)
CALL EXTOUT(PN,JJ2)
CALL EXTOUT(Q,JPQ)
IF(IPG.EQ.2)CALL EXIT
CALL FINEXT
LASTNM=NMPG
NMPG=NMPG+2
IF(NMPG.EQ.'PAGEZ'+2)NMPG='PAGFA'
C WILL GO FROM PAGEA TO PAGFZ, ETC. (104) ADD TO THIS IF NEEDED.
IF(NMPG.EQ.'PAGFZ'+2)NMPG='PAGGA'
IF(NMPG.EQ.'PAGGZ'+2)NMPG='PAGHA'
122 ENDLN=RNEXT
END
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C THIS ROUTINE GATHERS NUMBERED RESTS AND THINGS NEARBY AT END OF A LINE AND LATER
C00007 ENDMK
C⊗;
C THIS ROUTINE GATHERS NUMBERED RESTS AND THINGS NEARBY AT END OF A LINE AND LATER
C INSERTS THEM AT BEGINNING OF NEXT LINE.
SUBROUTINE RESTP
COMMON /POSI/STFF(8),JJ2,JPQ /PX/KPN(1) /Q/Q(1)
COMMON RS,JA,REST,J2,RQ(18),JX,PR,LX,RDIS
COMMON/XRN/RN(1) /XXX/LK,LP,JY /JN/J,N /IRST/IRST
1 /RSP/KNM(1) /ENDL/ENDLN,KQ,NAME,NMPG,SPCNT
DIMENSION MM(1),NN(1),RX(100),NNX(30)
C RX AND NNX ARRAYS STORE THINGS AND CODE NUMS FOR INSERT TO NEXT LINE.
EQUIVALENCE (MX,RX),(MM,RN),(NN,RN(501))
IF(IRST.EQ.0)GO TO 3
IF(NN(1).NE.2)GO TO 4
C NEXT IS A REST
IF(Q(MM(1)-3).LT.6)GO TO 4
IF(Q(MM(1)+5).LT.-3)GO TO 4
C NEXT IS NUMBERED REST.
M=3
INSRTS=0
16 IF(RX(M).EQ.2)GO TO 15
C LOOK FOR REST HELD FROM LAST TIME THROUGH
M=M+RX(M-1)+3
INSRTS=INSRTS+1
GO TO 16
C NOW FOUND NUMB. OF BARS REST HELD OVER. (IN RX(M+7) )
15 Q(MM(1)+5)=Q(MM(1)+5)+RX(M+7)
IRST=0
IF(INSRTS.EQ.0)GO TO 3
MX=M-2
C NOW SHIFT IN THINGS BEFORE A NUMBERED REST.
4 MX=MX-1
CALL SHFTQ(RE)
C PUSHES DATA TO RIGHT A BIT
DO 9 K=KPN(JJ2-1),1,-1
9 Q(K+MX)=Q(K)
RE=ENDLN+3
CXX RE=ENDLN
J=INSRTS
C THE WD CNT
K=5
21 RX(K)=RE
IF(J.EQ.1)GO TO 10
J=J-1
K=RX(K-3)+3+K
RE=RE+3
C SETS POS. FOR ITEMS INSERTED AT FRONT OF LINE.
GO TO 21
10 CALL RLOOP(Q,RX(2),MX)
DO 5 K=N+1,1,-1
J=K+INSRTS
NN(J)=NN(K)
MM(J)=MM(K)+MX
C SHIFT EVERYTHING
5 KPN(J)=KPN(K)+MX
N=N+INSRTS
JJ2=JJ2+INSRTS
KQ=KQ+MX
J=2
K=2
6 M=RX(K)+3
KPN(J)=KPN(J-1)+M
J=J+1
K=K+M
IF(K.LT.MX)GO TO 6
IRST=0
DO 7 K=1,INSRTS
MM(K)=KPN(K)+3
C ASSUMES NO SLURS, HORIZ. LINES, ETC. AT THIS POINT.
CC7 NN(K)=CODEN(KPN,K,Q,J)
7 NN(K)=NNX(K)
3 DO 1 K=N,1,-1
J=NN(K)
IF(J.GT.16)RETURN
IF(J.EQ.1)RETURN
IF(J.NE.4)GO TO 23
IF(Q(MM(K)+1).GE.1000)RETURN
C NO RESTS COMBINED OVER DOUBLE BARS.
23 IF(J.NE.2)GO TO 1
MK=K
IF(K.EQ.1)GO TO 13
17 M=MK-1
IF(NN(M).EQ.4)GO TO 13
C LOOK FOR BAR LINE BEFORE REST
MK=MK-1
C GET RIGHT GROUP OF ITEMS TO SAVE FOR NEXT TIME.(EVERYTHING BACK TO BAR.)
IF(MK.GT.1)GO TO 17
13 M=MM(K)
IF(Q(M-3).LT.6)RETURN
IF(Q(M+5).LT.-3)RETURN
C AVOID REPEAT BAR SIGN (P8=-5 OR -4)
IRST=-1
C NOW FOUND NUMBERED REST
IF(MK.NE.1)GO TO 8
IRST=-2
C -2 = ONLY RESTS ON THIS LINE.
8 M=1
RE=ENDLN+3
MX=0
J=MK
14 IF(NN(J).EQ.-1)MK=J+1
C***** CATCHES EVERYTHING TO LEFT OF -1 ITEM. (A P6,P8,P9) *****
12 J=J+1
IF(J.LE.N)GO TO 14
DO 20 J=MK,N
CC IF(NN(J).EQ.-1)GO TO 20
C SKIP IF -1 FOUND (REFERS TO PARAM OTHER THAN P3)
JX=MM(J)
MX=MX+1
NNX(MX)=NN(J)
c save nn data for later insert (at 7)
Q(JX)=RE
RE=RE+3
LX=Q(JX-3)+3
JX=JX-4
DO 2 JA=1,LX
M=M+1
2 RX(M)=Q(JA+JX)
C RX SAVES STUFF FOR NEXT TIME AROUND. THEN IT GETS SHIFTED TO FRONT OF Q ARRAY.
20 CONTINUE
MX=M
C WD CNT
JJ2=JJ2-N+MK-1
INSRTS =N-MK+1
C INSRTS SAVES COUNT O ITEMS TO BE INSERTED
N=MK-1
IF(IRST.EQ.-2)N=-N
RETURN
1 CONTINUE
END
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE PT2
C00013 ENDMK
C⊗;
SUBROUTINE PT2
DIMENSION BARS(1),JBAR(1),JRN(1),MBAR(1),JTRN(1),PGTRN(1)
1,IBAR(100),NNBAR(100)
COMMON /FIN/LBAR,METR,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2 /MNX/MIN,MAX,JT
COMMON /SF/KL,RT,KP,SIZE,NAMX /IPG/IPG,JPG,BRACK(0/7),
1 RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7) /RSIG/RSIG(0/7)
1 /KBAR/KBAR(1) /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T
COMMON RS,JA,RA,R,RB,RQ(15),KQ,NQ,JQ,JJQ,KBQ,NAQ /KNUM/KNUM
1 /STF/RSTFAC(0/7),RSTJ2 /IVV/IV(1) /ITX/ITX(19)
COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,ITRANS,I,RXQ,XSIG
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(200)
1/JLINE/JLINE,SIZX /BRJ/JTOT,TURN,NB,DSK,PGLNTH
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R6,RQ(4)),(R7,RQ(5)),(KT,KBAR)
1,(R8,RQ(6)),(R9,RQ(7)),(JRN,RN),(MBAR,RN(1000)),(KA,KBAR(1025))
1,(K,KBAR(1027)),(JTRN,Q),(J,KBAR(1026)),(PGTRN,KBAR(516))
1,(LCNT,IV(45)),(NDPY,IV(46)),(TOT,KBAR(2)),(JBAR,BARS,KBAR(4))
1,(IBAR,Q(3000)),(NNBAR,NBAR)
DATA JLINE/190/,HX/2./,ITX/'EF-','E-','F','GF','G','AF','A',
1 'BF','B',0,'DF','D','EF','E','F+','G+','BBF','O-','O+'/,
1 SLSP/11.0/,DIV/4./,PGLNTH/10.0/
INTEGER DSK
C O- = OCTAVE DOWN, O+ =OCTAVE UP. OR 1/2 STEP NUMS. MAY BE USED.
C JLINE=BASIC LINE LENGTH FAC.
C HX=HEIGHT MULTIPLIER, ZL=LN. LNGTH FACTOR.
C TRNSP'S ALL
145 FORMAT(F,3I)
IF(NAMX.NE.0)GO TO 2000
CALL GETEXT('BARS','PAG')
CALL EXTIN(KBAR,1024)
C STAFF NAMES BEGIN IN KBAR(508) [STFNM(0)7]
CALL EXTIN(RSTFAC,128)
2000 TYPE 144,RSTJ2
144 FORMAT(' STAFF SIZE='F4.2,' CHANGE TO '$)
ACCEPT 145,SIZE,DSK
C TYPE 2ND NUM TO WRITE BARS/LINE DATA ON DSK FILE FOR21.DAT
IF(DSK.NE.0)DSK=-1
XSIG=0
IF(IPG)GO TO 2001
C IF NOT PARTS, INDICATE 1ST PAGE NUM (TO START PAGE NUMS BEYOND 1)
TYPE 2002
2002 FORMAT(' FIRST PAGE NUMBER(0=1) AND PAGE LENGTH(0=10) -- '$)
ACCEPT 111,KNUM,K
IF(K.NE.0)PGLNTH=K
2001 TYPE 304
304 FORMAT(' TRANSP.= '$)
ACCEPT 2101,ITRANS
CALL LO2UP(ITRANS)
IF(ITRANS.GT.-20)GO TO 1101
2101 FORMAT(A3)
C NEXT FOR LETTER NAMES
DO 3101 K=1,19
3101 IF(ITRANS.EQ.ITX(K))GO TO 4101
5101 TYPE 240
GO TO 2000
240 FORMAT(' THIS TRANSP NOT OFFERED. ONLY THIS LIST IS AVAILABLE:'
1,/' EF-,E-,F,GF, G,AF,A,BF,B, DF,D,EF,E,F+,G+, BBF,O+,O-'/
1,' FOR OTHERS USE TWO PASSES.')
1101 REREAD 111,ITRANS
IF(ITRANS.EQ.0)GO TO 1304
IF(ITRANS.EQ.-12)GO TO 1011
IF(ITRANS.EQ.-10)GO TO 1011
IF(ITRANS.EQ.-7)GO TO 6101
IF(ITRANS.LT.-5)GO TO 5101
IF(ITRANS.EQ.12)GO TO 1011
IF(ITRANS.GT.9)GO TO 5101
1011 ITRANS=10-ITRANS
IF(ITRANS.EQ.22)ITRANS=18
C FOR DOWN OCT.
IF(ITRANS.EQ.-2)ITRANS=19
C -2 NOW = UP OCT.
GO TO 1304
6101 ITRANS=16
GO TO 1304
4101 ITRANS=K
1304 IF(SIZE.EQ.0)SIZE=RSTJ2
SIZX=SIZE
SIZE=SIZE/RSTJ2
CCC IF(TURN.EQ.0)TURN=1000.
101 JTOT=0
C ABOVE ASSUMES FIRST LINE ALWAYS HAS A CLEF.
DO 22 K=1,KT
JJ=BARS(K)*SIZX+.5
JBAR(K)=JJ
22 JTOT=JTOT+JJ
33 IF(RSTJ2.EQ.0)RSTJ2=1
IF(JPG.EQ.0)JPG=1
RA=JPG*SIZX
CC RA=JPG*SIZE*RSTJ2
MPG=PGLNTH/RA
C MPG=NUM OF SYSTEMS PER PAGE. PGLNTH=10 OR 13
190 FORMAT(' NUM. OF SYSTEMS/PAGE =',I2,/
1 ' CHANGE TO -- '$)
TYPE 190,MPG
ACCEPT 111,LPG
IF(LPG.NE.0)MPG=LPG
LPG=JPG
RA=0
90 FORMAT(' TOTAL BAR LINES='I3)
91 FORMAT(' NUMBER OF BARS PER LINE')
NPG=MPG
LTOT=JTOT
NB=1
CXX JT=TOT*RPG
CC JT=TOT*SIZE
JT=JTOT/JLINE+.5
C USE JLINE (190 FOR NOW) AS SUGGESTED LINE LENGTH)
609 TYPE 2003
2003 FORMAT(' FIND PAGE TURNS? '$)
ACCEPT 2101,K
CALL LO2UP(K)
TURN=1000.
KPG=0
IF(K.NE.'Y')GO TO 140
CALL FNDTRN(RPG,PGTRN,JBAR,IBAR,KT,KB)
IF(IBAR(1).NE.0)GO TO 119
140 TYPE 90,KT
TYPE 91
KPG=0
16 CALL BRJUGL(JBAR(1),KT,NBAR(1),MBAR(1),JRN(1),PGTRN(1)
1,JTRN(1))
RPG=JT
RPG=RPG/MPG
605 TYPE 604,RPG,JT,KT
IF(DSK)WRITE(21,604)RPG,JT,KT
TURN=1000.
NB=1
610 TYPE 608
604 FORMAT(F7.2,' PAGES',/,I4,' LINES',I6,' BARS')
608 FORMAT(/' TYPE LAYOUT NUMBERS(-1=HELP)-- '$)
C FOR 'T' TYPE X Y FOR X PAGES, Y LINES PER PAGE.
KKT=0
KA=0
K=JT
ACCEPT 145,T,N,KL,KB
C TYPE 0,n TO EXIT WITH n SPACING BETWEEN STAVES (2 IS DEFAULT)
IF(T)GO TO 700
C GO FOR HELP
IF(KL.NE.0.OR.KB.NE.0)GO TO 110
C NO MORE THAN 50 NUMS, INCLUDING 0S (FOR PAGE MARKS)
IF(T.NE.0)GO TO 115
REREAD 306,T,SPG
GO TO 11
306 FORMAT(2F)
115 JT=T
MPG=NPG
CC IF(T.EQ.JT)GO TO 210
CC MPG=(T-JT)*100.+.5
IF(N.GT.100)GO TO 110
IF(N.EQ.0)GO TO 16
C N=0 MEANS T= NUM OF LINES DESIRED.
MPG=N
C MPG=LINES PER PAGE, JT=TOTAL NUM OF BARS
KPG=MPG
JT=JT*MPG
IF(JT.LE.KT)GO TO 16
C CATCHES REQUEST FOR TOO MANY BARS.
JT=K
606 TYPE 607
GO TO 605
607 FORMAT(' WRONG NUMBER OF BARS')
111 FORMAT(100I)
110 REREAD 111,NNBAR
IF(NBAR(2).LT.100)GO TO 911
C NEXT FOR BARS PER PAGE SYSTEM. NNBAR IS EQUIV. TO NBAR.
DO 118 KB=1,100
KP=NBAR(KB)
IF(KP.EQ.0)GO TO 119
118 IBAR(KB)=NBAR(KB)
CC119 DO 112 KB=2,50,2
CC112 IF(IBAR(KB).EQ.0)GO TO 113
C ADDS UP BARS
119 IF(IBAR(KB-2).NE.KT)GO TO 606
C GO BACK IF MISMATCH
MB=0
LB=1
KA=1
RPG=0
114 KKT=IBAR(KA)-MB
NB=MB+1
MB=IBAR(KA)
C RESET MB FOR NEXT TIME AROUND
MPG=IBAR(KA+1)
KP=MPG/100
C GET NUM OF PAGES
MPG=MPG-KP*100
JT=MPG*KP
116 JTOT=0
DO 125 KE=NB,KKT+NB-1
125 JTOT=JTOT+JBAR(KE)
CALL BRJUGL(JBAR(NB),KKT,NBAR(LB),MBAR(NB),JRN(NB),PGTRN(NB)
1,JTRN(NB))
IF(KP.EQ.1)GO TO 122
C DOES ONLY ONE OR TWO PAGE UNITS
124 DO 123 KE=LB+JT+1,LB+MPG+1,-1
123 NBAR(KE)=NBAR(KE-1)
NBAR(LB+MPG)=0
LB=LB+MPG+1
122 KA=KA+2
LB=1+LB+MPG
C UPDATE NBAR COUNTER
1111 RPG=RPG+KP
IF(KA.LT.KB)GO TO 114
JT=MPG*RPG
CC KA=0
JTOT=LTOT
GO TO 605
911 DO 117 K=50,1,-1
KP=NBAR(K)
KA=KA+KP
117 IF(KP.EQ.0.AND.KA.EQ.0)KL=K
IF(KA.NE.KT)GO TO 606
C MISMATCH!
N=26-2*MOD(KL-1,12)
IF(N.EQ.26)N=0
C TO SPACE OUT STAVES VERTICALLY ???
DO 121 K=1,50
121 IF(NBAR(K).EQ.0)GO TO 120
120 MPG=K-1
CC11 SPG=PGLNTH/MPG
C MPG=NUM OF BRACES PER PAGE.
C SPG IS SPACE TO BE SET ABOVE STAFF 0
11 IF(KPG.NE.0)MPG=KPG
CALL WRTPAG
700 IF(T.LT.-1)GO TO 609
C TYPE -2 TO GET BACK 'PAGE TURN' MODE
TYPE 701
TYPE 90,KT
GO TO 610
701 FORMAT(' FOR SPECIFICATION OF HOW MANY BARS ON EACH LINE'//
1' A SINGLE NUMBER = NUMB. OF LINES ONLY.'//
1' TYPE X,Y FOR X PAGES, Y LINES PER PAGE.'/
1' 2,5=2 PAGES, 5 LINES, 4,10=4 PAGES, 10 LINES, ETC.'//
1' M1,M2,...0 N1,N2,...0 = ZEROS ARE PAGE MARKS.'/
1' N''S ARE NUMB. OF BARS PER LINE.'//
1' N X0A M Y0B K Z0C ETC. = '/
1' A = NUM OF LINES/PAGE, N=NUMB OF BARS/PAGE(S),
1 X =NUMB OF PAGES.'/
1' EXAMPLE: 40 208 = 8 LINES/PAGE, 40 BARS ON 2 PAGES.'//
1' NEGATIVE NUMBS IN BAR LIST ARE POSSIBLE PAGE TURN POINTS.'/
1' TYPE -2 TO RETURN TO "PAGE TURN" MODE.'/)
CCC 1' 0 N = EXITS WITH N" SPACE BETWEEN STAVES.'//
END
COMMENT ⊗ VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 SUBROUTINE WRTPAG
C00016 ENDMK
C⊗;
SUBROUTINE WRTPAG
DATA SLSP/12.0/
COMMON /FIN/JBAR,NPX,REND,KPX,KREAD,JEND,JSLUR,JSL2,NAMZ
1,LC,LPG,MPG,CLEF,SIG,LB,SPG,MTR1,MTR2/JLINE/JLINE,SIZX
1 /SF/KL,RT,KP,SIZE,NAMX,EXT /IPG/IPG
1 ,JPG,BRACK(0/7),RSTNUM(8),RPSZ(8),RHGT(8),RCLEF(0/7)
1 /RSP/KNM(1) /ENDL/ENDLN,N,NAME,NMPG,T /KBAR/KBAR(515)
1 /RCLF/KK,CL,KW,ITEM,RSTAFF,SN,YN,RNAM,RNAM2,ITR
COMMON RS,JA,CLEFQ,AA,RQ(16),KQ,NQ,JQ,JJQ,KBQ,NAQ
COMMON/STF/RSTFAC(0/7),RSTJ2 /IVV/IV(1) /KNUM/KNUM
COMMON /POSI/STFF(0/7),JJ2,JPQ /LLL/L,LL,I,RXQ
1/PX/KPN(1) /Q/Q(1) /PTR/KWDS(1) /XRN/RN(1) /NBAR/NBAR(1)
1/BRJ/JTOT,TURN,NB,DSK,PGLNTH
DIMENSION ENDSTF(450)
C ENDSTF AND ENDPTR FOR CARRYING STUFF FROM ONE LINE TO THE NEXT.
EQUIVALENCE (RQ(2),R4),(R5,RQ(3)),(R7,RQ(5))
1,(R8,RQ(6)),(LCNT,IV(45)),(NDPY,IV(46)),(ENDSTF,KBAR(4))
DATA VERT/0.045/
C VERT IS BASIC VERTICAL UNIT SIZE IN INCHES
IF(MPG.NE.0)GO TO 4
DO 1 K=1,100
1 IF(NBAR(K).EQ.0)GO TO 3
3 MPG=K-1
C SETS NUMB. OF LINES ON FIRST PAGE
4 IF(SPG.EQ.0)SPG=PGLNTH/MPG
RS=SIZE*17.5
HX=0
CC RA=(RSTJ2*SIZE)/RPSZ(1)
RA=RPSZ(JPG)
C SAVE SIZE OF TOP STAFF FOR LATER
DO 141 K=1,JPG
RB=RSTNUM(K)
C ADJUSTS DIST. BETWEEN STAVES DEPENDING ON SIZE FACTOR.
RHGT(K)=RHGT(K)+RB*(RS-17.5)
CC RPSZ(K)=RPSZ(K)*RA
141 RPSZ(K)=RPSZ(K)*SIZE
CC141 HX=HX+(RHGT(K)+17.5)*RPSZ(K)*RT
CZZ HX=(17.5*RSTNUM(JPG)+17.5)*VERT
HX=(17.5*RSTNUM(JPG)+17.5+RHGT(JPG)*RA)*VERT
C HX=TOTAL HEIGHT IN INCHES. THIS ASSUMES RSTNUM(JPG) IS HIGHEST STAFF NUM.
C ALSO ASSUMES HIGHEST STAFF NUM. IS REALLY ABOVE ALL OTHERS.
143 IF(HX.LE.SPG)GO TO 140
HX=SPG/HX
C GET THE FACTOR FOR SPACE BETWEEN STAVES
CZZ DO 142 K=1,LPG
CZZ RA=17.5*RSTNUM(K)
CZZ142 RHGT(K)=RA*HX-RA
RA=1/HX
DO 142 K=1,JPG
SP=RHGT(K)
IF(SP)GO TO 1142
C MULT +S * <1, -S * >1 TO REDUCE SIZE
SP=SP*HX
GO TO 142
1142 SP=SP*RA
142 RHGT(K)=SP
CC142 RHGT(K)=(RA+RHGT(K))*HX-RA
140 NPG=1
NMPG='PAGEA'
HORZ=96.
IF(KNUM.GT.0)KNUM=KNUM-1
C FOR PAGE NUMS.
IF(MOD(KNUM,2).NE.0)HORZ=-HORZ
RNUM=0.+KNUM
LB=0
ITR=LL
C TRANSPOSE IS IN LL
RA=0
JEND=-1
METR=1000
CLEF=-99
JSLUR=0
LC=1
KREAD=128
SIG=CLEF
HX=2
KQ=1
KPX=1
CALL FILOUT
C NAMQ AND NPG ARE SET IN FILOUT
SP=2.45
C DEFAULT VERT. SPACE UNITS
ENDSTF(1)=0
IF(N.EQ.0)GO TO 100
C SPACED OUT DEPENDING ON NUM OF LINES
HX=N
SP=SP+(HX-2.)*.11
100 CALL FILEIN
320 CALL STAVES
CC IF(IPG)GO TO 3000
IF(NPG.NE.1)GO TO 3000
RT=RSTNUM(JPG)
RS=100.+HORZ
HORZ=-HORZ
RNUM=RNUM+1
C ADDS PAGE NUMBER. SIZE(P6)=1.1 P7=3 SO PARTS PROG. WILL IGNORE IT.
CALL STAFF(5.,10.,RS,28.,RNUM,1.1,3.0,0,0,0,0,0)
3000 IF(ITR.NE.0)CALL TRNSP
JPQ=KL
NA=0
KPT=1
ENDSTF(1)=0
C LOOP STARTS HERE *******
131 NA=NA+1
KWDS(KP)=JPQ
KP=KP+1
R=CODEN(KPN,NA,Q,JK)
RR=Q(JK+6)
RS=Q(JK)
IF(R.NE.5)GO TO 935
R8=-1
IF(RS.GE.6)R8=Q(JK+8)
IF(RR)GO TO 735
IF(RR.LE.Q(JK+3))RR=201.
GO TO 235
C CATCHES SLURS, TRILLS, 8VA, LINES THAT GO PAST END OF LINE.
935 IF(R.EQ.7)GO TO 835
IF(R.NE.44)GO TO 35
R=R/11.
Q(JK+1)=R
C INFOR FOR P9 AND L10 OF DASHES AND WIGGLES NOT KEPT YET!!!!!!!
IF(RR.LT.Q(JK+3))GO TO 30
C NEEDED WHEN DATA ON LINE HAS BEEN EXPANDED, NOT CONTRACTED.
835 R8=0
R7=0
IF(RS.GE.6)R8=Q(JK+8)
235 IF(RR.LT.199.)GO TO 30
C P1,P2,P3,P4,P5,P6,P7,P8 ARE SAVED.
RR=-1
735 IF(RS.GE.5)R7=Q(JK+7)
R4=Q(JK+4)
IF(R.NE.5)GO TO 1735
IF(ABS(R7).LE.1.5)GO TO 2735
C=1.5
C LIMIT CURVE OF SLUR AT END OF LINE TO +-2
IF(R7)C=-C
Q(JK+7)=C
2735 IF(R4.NE.Q(JK+5))GO TO 1735
C IF A SLUR - AND END HGTS ARE SAME MAKE CURVE 1 OR -1.
C=1
IF(R7)C=-C
R7=C
1735 ENDSTF(KPT)=6
ENDSTF(KPT+1)=R
CC C=Q(JK+2)
CC ENDSTF(KPT+2)=C
ENDSTF(KPT+2)=Q(JK+2)
ENDSTF(KPT+3)=1
CC ENDSTF(KPT+4)=Q(JK+4)
ENDSTF(KPT+4)=R4
ENDSTF(KPT+5)=Q(JK+5)
ENDSTF(KPT+7)=R7
ENDSTF(KPT+8)=R8
ENDSTF(KPT+6)=RR
236 KPT=KPT+13
ENDSTF(KPT)=0
Q(JK+6)=201
GO TO 30
C*************
35 IF(R.NE.2)GO TO 36
IF(RS.EQ.7)GO TO 30
C SKIP ALL THIS IF NEW CENTERING (P9 NOW HAS POS.)
IF(RS.LT.6.)GO TO 30
RR=RIGHT(NA,-1,JK)
Q(JK+3)=RR-1.6*RSTJ2+(RIGHT(NA,1,JK)-RR)/2.
C FUNCTION 'RIGHT' FINDS ITEMS TO LFT AND RT OF REST FOR CENTERING.
C CENTERS WHOLE REST
GO TO 30
36 IF(R.NE.3)GO TO 34
CLEF=CLEFN(Q,JK)
LL=Q(JK+2)
C GETS CLEF FOR PAGE LAYOUT
RCLEF(LL)=CLEF
GO TO 30
34 IF(R.NE.17)GO TO 37
SIG=Q(JK+5)
IF(ABS(SIG).GT.100.)SIG=-99
C DO NOT REPEAT KSIG MADE UP OF NATURALS.
CXX IF(Q(JK).GT.3)SIG=SIG+Q(JK+6)*100.
CXX CLEF # IN P6 WITH KEY SIGS.
C NEXT CHANGES CODE NUM BACK TO ORIGINAL
37 IF(R.LT.33)GO TO 130
38 Q(JK+1)=R/11.
GO TO 30
130 IF(Q(JK+3).LT.199)GO TO 30
IF(R.NE.18)GO TO 30
C FIND A METER?
KKK=K+1
R3=9
IF(SIG.NE.-99)R3=10
KK=JK
435 LL=KPN(KKK)
C WDCNT,P1,P2,P3,P4,P5,P6,P7,P8
ENDSTF(KPT)=Q(KK)
ENDSTF(KPT+1)=R
ENDSTF(KPT+2)=Q(KK+2)
ENDSTF(KPT+3)=R3
DO 535 JJ2=4,12
535 ENDSTF(KPT+JJ2)=Q(KK+JJ2)
KPT=KPT+13
ENDSTF(KPT)=0
RS=Q(LL+1)
IF(RS.LE.4)GO TO 30
R4=Q(LL+2)
C SAVE THE STAFF NUM. IN R4
IF(RS.NE.18)GO TO 7011
335 R3=R3+6
KK=LL
KKK=KKK+1
GO TO 435
7011 RS=CODEN(KPN,KKK+1,Q,LL)
IF(RS.LE.4)GO TO 30
IF(Q(LL+2).NE.R4)GO TO 30
IF(RS.EQ.18)GO TO 335
30 JPQ=KPN(NA+1)-KPN(NA)+JPQ
IF(NA.LT.I)GO TO 131
C END OF LOOP ****************
CALL PSHFT(I)
C NEXT GETS RID OF USELESS SLURS (NO LENGTH)
K=1
441 IF(CODEN(KWDS,K,RN,J).NE.5)GO TO 41
IF(ABS(RN(J+6)-RN(J+3)).GT..2)GO TO 41
C NEXT DELETES THE SLUR
LL=RN(J)+3
DO 241 NA=J,JPQ
241 RN(NA)=RN(NA+LL)
JPQ=JPQ-LL
CCC LL=KPN(K+2)-KPN(K+1)-LL
I=I-1
KP=KP-1
DO 341 NA=K+1,KP
341 KWDS(NA)=KWDS(NA+1)-LL
GO TO 441
41 K=K+1
IF(K.LT.KP-1)GO TO 441
RS=-1
C -1 FOR ALL STAVES AT ONCE IN GETPTS.
CCC RS=RT
LL='J'
R4=0
R5=200
NA=L
L=KP-1
IF(IPG.GE.0)GO TO 46
C JUMP IF NOT IN 'PARTS' MODE (SINGLE STAFF)
RSTFAC(0)=SIZX
GO TO 246
46 DO 146 K=0,JPG-1
146 RSTFAC(K)=RSTFAC(K)*SIZE
C GETS PROPER SIZE FACTORS FOR JUSTIFY SUBR.
246 CALL PTMOVE(RN,KWDS)
C START LAST LOOP *******
CC DO 47 JJ2=1,KP
CC LL=KWDS(JJ2)
CC AA=RN(LL+1)
CC IF(AA.NE.10.AND.AA.NE.16)GO TO 1047
CN IF(AA.NE.10.AND.AA.NE.16)GO TO 347
C***** SKIP NEXT FOR NOW ******* 1/28/78
CC GO TO 47
CC DO 147 NN=JJ2+1,KP
CC MM=KWDS(NN)
CC IF(RN(MM+1).NE.16)GO TO 147
C FOUND THE NEXT TEXT AFTER TEXT OR NUMB.
CC IF(RN(MM).EQ.8)GO TO 47
C JUMP IF POS. IS ALREADY TAKEN CARE OF.
CC IF(AA.EQ.10)GO TO 247
C NEXT FOR TEXT FOLLOWING TEXT
CC IF(ABS(RN(MM+4)-RN(LL+4)).GE.4)GO TO 47
C JUMP IF ON DIFF. VERT. PLANE.
CC AA=(RN(LL+9)+4.)*RSTJ2*RN(LL+5)+RN(LL+3)
C SETS MINIMUM SPACE.
CC IF(RN(MM+3).LT.AA)RN(MM+3)=AA
CC GO TO 47
CC247 IF(ABS(RN(MM+4)-RN(LL+4)).GT.6)GO TO 47
C CHECKS VERT. POS.
CC AA=RN(LL+4)+7
CC IF(RN(MM+4)-AA.LT.0)RN(MM+4)=AA
C MOVE WORD TO RIGHT OF NUMBER IF IT WAS TOO CLOSE
CC GO TO 47
CC147 CONTINUE
CC GO TO 47
CC1047 IF(AA.NE.6)GO TO 47
CC IF(RN(LL).LT.7)GO TO 47
CC IF(RN(LL+9).GT.200.)RN(LL+9)=0
C ********** FIX THIS IN GETPTS, MOVER. IT SHOULDN'T MOVE P9 ALWAYS.
CC47 CONTINUE
2 KWDS(KP)=JPQ
CP J=1
IF(KP.GE.300.OR.JPQ.GE.2500)TYPE 20,KP,JPQ
JJ2=KP+1
C WRITES 1 EXTRA WORD
CP JPQ=KB
DO 12 K=1,KP
CC N=KWDS(K)
CC R=RN(N+1)
R=CODEN(KWDS,K,RN,N)
IF(R.LE.2)GO TO 22
C ONCE IT FINDS A REST OR NOTE IT MUST HAVE GONE TOO FAR.
IF(R.GT.7)GO TO 12
IF(R.EQ.5)GO TO 52
IF(R.NE.4)GO TO 62
IF(RN(N).GE.4)GO TO 52
62 IF(R.NE.7)GO TO 12
52 A=RN(N+6)
C J HAS NOTE COUNT TO FIND POS OF RIGHT END OF SLUR.
IF(A.GE.0)GO TO 12
J=A
IF(J.EQ.0)J=-1
B=RN(N+2)
C B=STAFF NUM.
JJ=0
DO 32 KK=K+1,KP
CC NN=KWDS(KK)
CC A=RN(NN+1)
R3=CODEN(KWDS,KK,RN,NN)
IF(R3.NE.1)GO TO 32
IF(B.NE.RN(NN+2))GO TO 32
D=RN(NN+3)
JJ=JJ-1
IF(J.NE.JJ)GO TO 32
CCC IF(J.NE.JJ)GO TO 42
3232 RN(N+6)=D
CC3232 RN(N+6)=D+(D-A)*(RN(N+6)-J)
C FOUND NOTE FOR POSITION.
IF(R.NE.5)GO TO 12
IF(J.EQ.-1)GO TO 12
IF(ABS(RN(N+7)).NE.1)GO TO 12
C NOW FIX UP CURVATURE OF SLUR. ('FAIL' ROUTINE)
D=RCURVE(RN(N+3))
RN(N+7)=D
GO TO 12
CC42 A=D
32 CONTINUE
12 CONTINUE
22 CALL PUTEXT(NAMX,EXT)
LCNT=0
CC NDPY=0
RSTFAC(99)=0
C MUST BE 0 IN MS TO MAKE DISPLAY
CALL EXTOUT(RSTFAC,128)
CALL EXTOUT(KWDS,JJ2)
CALL EXTOUT(RN,JPQ)
TYPE 101,NAMX,EXT
NAMX=NAMX+2
CC IF(IPG)GO TO 6011
NPG=NPG+1
IF(NBAR(LC).NE.0)GO TO 220
KK=LC+1
IF(NBAR(KK).EQ.0)GO TO 220
CHECK FOR ZEROS WHICH ARE PAGE MARKS.
LC=LC+1
221 KK=KK+1
IF(NBAR(KK).NE.0)GO TO 221
C FIND NEW MPG
MPG=KK-LC
NPG=1000
SPG=10./MPG
JEND=0
C RESET ABOVE
220 IF(NPG.LE.MPG)GO TO 6011
NPG=1
C RESET, UPDATE FILENAMES
NAMX=NAMZ+256
NAMZ=NAMX
6011 NAMQ=NAMX
CALL FINEXT
GO TO 100
C IPG=1 = GO BACK TO TRONLY INSTEAD
101 FORMAT(1XA5,'.',A3)
20 FORMAT(' TOO MUCH DATA!!! ',I3,'/300',I5,'/2500')
END